home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / modops.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  7.9 KB  |  341 lines
  1. /* ******************************************************************** */
  2. /* modops.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Dynamic module manipulation                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, June 1990 
  10.  */
  11.  
  12. #include "funcalls.h"
  13. #include "defs.h"
  14. #include "structs.h"
  15. #include "error.h"
  16. #include "global.h"
  17.  
  18. #include "symboot.h"
  19. #include "allocate.h"
  20. #include "modules.h"
  21. #include "specials.h"
  22. #include "modboot.h"
  23. #include "root.h"
  24.  
  25. /* Dynamic module loading... */
  26.  
  27. EUFUN_1( Fn_dynamic_load_module, name)
  28. {
  29.   extern LispObject load_module(LispObject*);
  30.  
  31.   if (!is_symbol(name))
  32.     CallError(stacktop,
  33.           "dynamic-load-module: not a symbolic name",name,NONCONTINUABLE);
  34.  
  35.   EUCALL_1(load_module,name);
  36.  
  37.   return(get_module(stacktop,ARG_0(stackbase)));
  38. }
  39. EUFUN_CLOSE
  40.  
  41. extern LispObject Fn_module_value(LispObject*);
  42.  
  43. EUFUN_2( Fn_dynamic_accessiblep, mod, sym)
  44. {
  45.   if (!is_symbol(sym))
  46.     CallError(stacktop,"dynamic-accessiblep: non-symbol",sym,NONCONTINUABLE);
  47.  
  48.   if (!is_i_module(mod) && !is_c_module(mod))
  49.     CallError(stacktop,"dynamic-accessiblep: non-module",mod,NONCONTINUABLE);
  50.  
  51.   return((module_binding_exists_p(stacktop,mod,sym) ? lisptrue : nil));
  52. }
  53. EUFUN_CLOSE
  54.  
  55. EUFUN_2( Fn_dynamic_access, mod, sym)
  56. {
  57.   if (!is_symbol(sym))
  58.     CallError(stacktop,"dynamic-access: non-symbol",sym,NONCONTINUABLE);
  59.  
  60.   return(EUCALL_2(Fn_module_value,mod,sym));
  61. }
  62. EUFUN_CLOSE
  63.  
  64. EUFUN_1( Fn_get_module, sym)
  65. {
  66.   LispObject val;
  67.  
  68.   if (!is_symbol(sym))
  69.     CallError(stacktop,"get-module: non-symbol",sym,NONCONTINUABLE);
  70.  
  71.   val = get_module(stacktop,sym);
  72.  
  73.   return(val);
  74. }
  75. EUFUN_CLOSE
  76.  
  77. EUFUN_1( Fn_module_name, mod)
  78. {
  79.   if (!is_i_module(mod) && !is_c_module(mod))
  80.     CallError(stacktop,"module-name: not a module",mod,NONCONTINUABLE);
  81.  
  82.   return(mod->I_MODULE.name);
  83. }
  84. EUFUN_CLOSE
  85.  
  86. EUFUN_1( Fn_module_exports, mod)
  87. {
  88.   if (!is_i_module(mod) && !is_c_module(mod))
  89.     CallError(stacktop,"module-exports: not a module",mod,NONCONTINUABLE);
  90.  
  91.   return(mod->I_MODULE.exported_names); /* Should copy... */
  92. }
  93. EUFUN_CLOSE
  94.  
  95. EUFUN_2(Fn_add_module_export, mod, name)
  96. {    
  97.   LispObject xx;
  98.  
  99.   xx=EUCALL_2(Fn_cons,name, mod->I_MODULE.exported_names);
  100.   mod->I_MODULE.exported_names=xx;
  101.   return nil;
  102. }
  103. EUFUN_CLOSE
  104.  
  105. /* Module junk for bytecode interpreter */
  106.  
  107. EUFUN_2(Fn_make_module, name, nbinds )
  108. {
  109.   char *myspace;
  110.   LispObject newmod,tab;
  111.   LispObject *binds;
  112.   int i;
  113.  
  114.   myspace=allocate_space(stacktop,intval(nbinds)*sizeof(LispObject)+sizeof(MODULE));
  115.   tab=allocate_table(stacktop,Fn_eq);
  116.   
  117.   newmod=(LispObject) myspace;
  118.   binds=(LispObject *) (myspace+sizeof(MODULE));
  119.   
  120.   for (i=0; i<intval(nbinds); i++)
  121.     {
  122.       binds[i]=nil; /* NULL maybe */
  123.     }
  124.   
  125.   lval_classof(newmod)=Object;
  126.   lval_typeof(newmod)=TYPE_C_MODULE;
  127.   /* hack */
  128.   gcof(newmod)=gcof(nil);
  129.   newmod->MODULE.name=name;
  130.   newmod->MODULE.imported_modules=nil;
  131.   newmod->MODULE.bindings=tab;
  132.   newmod->MODULE.exported_names=nil;
  133.   newmod->C_MODULE.values=binds;
  134.   newmod->C_MODULE.entry_count=intval(nbinds);
  135.   put_module(stacktop,newmod->MODULE.name,newmod);
  136.  
  137.   return newmod;
  138. }
  139. EUFUN_CLOSE
  140.  
  141. static EUFUN_2(Fn_binding_location,mod,name)
  142. {
  143.   LispObject bind;
  144.  
  145.   bind=GET_BINDING(mod,name);
  146.  
  147.   return (BINDING_VALUE(bind));
  148. }
  149. EUFUN_CLOSE
  150.  
  151. static EUFUN_4(Fn_add_import,mod,name,inmod,inname)
  152. {
  153.   LispObject bind;
  154.  
  155.   bind=GET_BINDING(inmod,inname);
  156.  
  157.   IMPORT_BINDING(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*name*/,bind);
  158.   
  159.   return nil;
  160. }
  161. EUFUN_CLOSE
  162.  
  163. EUFUN_3(Fn_add_binding,mod,name,loc)
  164. {
  165.   
  166.   ADD_BINDING(ARG_0(stackbase)/*mod*/,name,loc,nil);
  167.   
  168.   return nil;
  169. }
  170. EUFUN_CLOSE
  171.  
  172. static EUFUN_2(Fn_module_val,mod,n)
  173. {
  174.   return ((mod->C_MODULE.values)[intval(n)]);
  175. }
  176. EUFUN_CLOSE
  177.  
  178. static EUFUN_3(Fn_module_val_setter,mod,n,val)
  179. {
  180.   (mod->C_MODULE.values)[intval(n)]=val;
  181.   
  182.   return nil;
  183. }
  184. EUFUN_CLOSE
  185.  
  186. /* DJB Type hacks */
  187. /* would be real nice if this was a function */
  188. EUFUN_3(Sf_reify_env,mod,env,form)
  189. {
  190.   LispObject lst=nil;
  191.   Env ptr;
  192.   
  193.   ptr=&(env->ENV);
  194.  
  195.   while (ptr!=NULL)
  196.     {
  197.       LispObject xx;
  198.  
  199.       STACK_TMP(ptr->next);
  200.       STACK_TMP(lst);
  201.       xx=EUCALL_2(Fn_cons,ptr->variable,ptr->value);
  202.       UNSTACK_TMP(lst);
  203.       lst=EUCALL_2(Fn_cons,xx,lst);
  204.       UNSTACK_TMP(ptr);
  205.     }
  206.   lst=EUCALL_2(Fn_cons,ARG_0(stackbase)->MODULE.name,lst);
  207.   return lst;
  208. }
  209. EUFUN_CLOSE
  210.  
  211. EUFUN_2(Fn_make_function, envlst, body)
  212. {    /* CAR(body) should be an arglist */
  213.  
  214.   LispObject env=NULL;
  215.   LispObject mod;
  216.   LispObject ptr=CDR(envlst);
  217.   
  218.   while(ptr!=nil)
  219.     {
  220.       STACK_TMP(CDR(ptr));
  221.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  222.       
  223.       UNSTACK_TMP(ptr);
  224.     }
  225.   
  226.   STACK_TMP(env);
  227.   mod=get_module(stacktop,CAR(ARG_0(stackbase))/*name*/);
  228.   UNSTACK_TMP(env);
  229.  
  230.   return(EUCALL_3(Sf_lambda,mod,env,ARG_1(stackbase)));
  231. }
  232. EUFUN_CLOSE
  233.  
  234. static EUFUN_1(Fn_function_body, fn)
  235. {
  236.   if (!is_i_function(fn))
  237.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  238.   
  239.   /*Should add the lambda-list! */
  240.   return fn->I_FUNCTION.body;
  241. }
  242. EUFUN_CLOSE
  243.  
  244. EUFUN_1(Fn_function_env, fn)
  245. {
  246.   LispObject lst=nil;
  247.   Env ptr;
  248.   
  249.   if (!is_i_function(fn))
  250.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  251.  
  252.   ptr=fn->I_FUNCTION.env;
  253.  
  254.   while (ptr!=NULL)
  255.     {
  256.       LispObject xx;
  257.  
  258.       STACK_TMP(ptr->next);
  259.       STACK_TMP(lst);
  260.       xx=EUCALL_2(Fn_cons,ptr->variable,ptr->value);
  261.       UNSTACK_TMP(lst);
  262.       lst=EUCALL_2(Fn_cons,xx,lst);
  263.       UNSTACK_TMP(ptr);
  264.     }
  265.   lst=EUCALL_2(Fn_cons,(fn->I_FUNCTION.home)->MODULE.name,lst);
  266.   return lst;
  267. }
  268. EUFUN_CLOSE
  269.  
  270. EUFUN_2(Fn_modify_function_env, fn, envlst)
  271. {
  272.   LispObject env=NULL;
  273.   LispObject mod;
  274.   LispObject ptr=CDR(envlst);
  275.   
  276.   if (!is_i_function(fn))
  277.     CallError(stacktop,"Fn_body: not an i-function",fn,NONCONTINUABLE);
  278.  
  279.   while(ptr!=nil)
  280.     {
  281.       STACK_TMP(CDR(ptr));
  282.       env=allocate_env(stacktop,CAR(CAR(ptr)),CDR(CAR(ptr)), env);
  283.       
  284.       UNSTACK_TMP(ptr);
  285.     }
  286.   
  287.   STACK_TMP(env);
  288.   mod=get_module(stacktop,CAR(ARG_1(stackbase))/*name*/);
  289.   UNSTACK_TMP(env);
  290.  
  291.   fn->I_FUNCTION.env = env;
  292.   fn->I_FUNCTION.home = mod;
  293.  
  294.   return fn;
  295. }
  296. EUFUN_CLOSE
  297.  
  298. /*
  299.  
  300.  * Initialisation...
  301.  
  302.  */
  303.  
  304. #define MODULE_OPERATORS_ENTRIES 18
  305.  
  306. MODULE Module_module_operators;
  307. LispObject Module_module_operators_values[MODULE_OPERATORS_ENTRIES];
  308.  
  309. void initialise_module_operators(LispObject *stacktop)
  310. {
  311.   open_module(stacktop,
  312.           &Module_module_operators,
  313.           Module_module_operators_values,
  314.           "module-operators",
  315.           MODULE_OPERATORS_ENTRIES);
  316.  
  317.   (void) make_module_function(stacktop,
  318.                   "dynamic-load-module",Fn_dynamic_load_module,1);
  319.   (void) make_module_function(stacktop,"dynamic-access",Fn_dynamic_access,2);
  320.   (void) make_module_function(stacktop,
  321.                   "dynamic-accessible-p",Fn_dynamic_accessiblep,2);
  322.   (void) make_module_function(stacktop,"get-module",Fn_get_module,1);
  323.   (void) make_module_function(stacktop,"module-name",Fn_module_name,1);
  324.   (void) make_module_function(stacktop,"module-exports",Fn_module_exports,1);
  325.  
  326.   (void) make_module_function(stacktop,"add-module-export",Fn_add_module_export,2);
  327.   (void) make_module_function(stacktop,"make-module",Fn_make_module,2);
  328.   (void) make_module_function(stacktop,"module-binding-location",Fn_binding_location,2);
  329.   (void) make_module_function(stacktop,"add-module-import",Fn_add_import,4);
  330.   (void) make_module_function(stacktop,"add-module-binding",Fn_add_binding,3);
  331.   (void) make_module_function(stacktop,"module-value",Fn_module_val,2);
  332.   (void) make_module_function(stacktop,"module-value-setter",Fn_module_val_setter,3);
  333.   (void) make_module_special(stacktop,"reify-env",Sf_reify_env);
  334.   (void) make_module_function(stacktop,"make-function",Fn_make_function,2);
  335.   (void) make_module_function(stacktop,"function-body",Fn_function_body,1);
  336.   (void) make_module_function(stacktop,"function-env",Fn_function_env,1);
  337.   (void) make_module_function(stacktop,"modify-function-env",Fn_modify_function_env,2);
  338.   close_module();
  339. }
  340.  
  341.